home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 September (IDG) / Sep99.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / AlphaBits.tcl next >
Encoding:
Text File  |  1999-04-28  |  9.8 KB  |  349 lines  |  [TEXT/ALFA]
  1. # First basic initialisation: (works with Alpha 7.2 or 8.0 development)
  2. if {[catch {
  3.     if {[info tclversion] < 8.0} {
  4.     ;proc namespace {cmd ns script} {if {$script != ""} {uplevel $script}}
  5.     ;proc variable {n} { global mode ; uplevel 1 [list upvar \#0 $mode::$n $n] }
  6.     ;proc renameMenuItem {args} {}
  7.     } else {
  8.     namespace eval alpha {
  9.         namespace eval index {}
  10.         namespace eval cache {}
  11.     }
  12.     namespace eval win {}
  13.     if {[info commands scancontext] == ""} {
  14.         proc scancontext {cmd args} {
  15.         switch -- $cmd {
  16.             "create" {
  17.             uplevel 1 {
  18.                 set __scan 0
  19.                 while {[array exists scancontext$__scan]} {
  20.                 incr __scan
  21.                 }
  22.                 set scancontext[set __scan]() 1
  23.                 return scancontext$__scan
  24.             }
  25.             }
  26.             "delete" {
  27.             upvar [lindex $args 0] scan
  28.             unset scan
  29.             }
  30.         }
  31.         }
  32.     
  33.         proc scanmatch {scanid regexp script args} {
  34.         if {[string match "-*" $scanid]} {
  35.             set flags $scanid
  36.             set scanid $regexp
  37.             set regexp [list $flags $script]
  38.             set script [lindex $args 0]
  39.         } else {
  40.             set regexp [list -- $regexp]
  41.         }
  42.         upvar $scanid scan
  43.         set scan($regexp) $script
  44.         return $scanid
  45.         }
  46.     
  47.         proc scanfile {scanid fid} {
  48.         upvar $scanid scan
  49.         upvar matchInfo m
  50.         set m(linenum) 0
  51.         set m(offset) 0
  52.         set names [array names scan]
  53.         while {[set count [gets $fid m(line)]] >= 0} {
  54.             incr m(linenum)
  55.             incr m(offset) [expr {$count +1}]
  56.             foreach reg $names {
  57.             if {$reg == ""} {continue}
  58.             if {[regexp [lindex $reg 0] [lindex $reg 1] $m(line) \
  59.               "" m(submatch0) m(submatch1) m(submatch2)]} {
  60.                 incr m(offset) [expr {-[string length $m(submatch0)]}]
  61.                 uplevel 1 $scan($reg)
  62.                 incr m(offset) [string length $m(submatch0)]
  63.             }
  64.             }
  65.         }
  66.         }
  67.     }
  68.     if {[info commands objDialog] != ""} {
  69.         rename dialog ""
  70.         rename objDialog dialog
  71.     }
  72.     rename lsort __lsort
  73.     proc lsort {args} {
  74.         if {[lindex $args 0] == "-ignore"} {
  75.         eval __lsort -dictionary [lrange $args 1 end]
  76.         } else {
  77.         eval __lsort $args
  78.         }
  79.     }
  80.     rename glob __glob
  81.     proc glob {args} {
  82.         if {[lindex $args 0] == "-t"} {
  83.         eval __glob [lrange $args 2 end]
  84.         } else {
  85.         eval __glob $args
  86.         }
  87.     }
  88.     # Tcl 8.0 doesn't handle \t \r \n , but Tcl 8.1 will
  89.     if {[info tclversion] == 8.0} {
  90.         rename regexp __regexp
  91.         proc regexp {args} {
  92.         set i 0
  93.         while {[string match -* [set a [lindex $args $i]]]} {
  94.             incr i
  95.             if {$a == "--"} {
  96.             set a [lindex $args $i]
  97.             break
  98.             }
  99.         }
  100.         __regsub -all "\\\\t" $a "\t" a
  101.         __regsub -all "\\\\r" $a "\r" a
  102.         __regsub -all "\\\\n" $a "\n" a
  103.         __regsub -all "\\\\w" $a "\[a-zA-Z0-9_\]" a
  104.         uplevel __regexp [lreplace $args $i $i $a]
  105.         }
  106.         rename regsub __regsub
  107.         proc regsub {args} {
  108.         set i 0
  109.         while {[string match -* [set a [lindex $args $i]]]} {
  110.             incr i
  111.             if {$a == "--"} {
  112.             set a [lindex $args $i]
  113.             break
  114.             }
  115.         }
  116.         __regsub -all "\\\\" $a "¢¢" a
  117.         __regsub -all "\\\\t" $a "\t" a
  118.         __regsub -all "\\\\r" $a "\r" a
  119.         __regsub -all "\\\\n" $a "\n" a
  120.         __regsub -all "\\\\w" $a "\[a-zA-Z_\]" a
  121.         __regsub -all "¢¢" $a "\\\\" a
  122.         uplevel __regsub [lreplace $args $i $i $a]
  123.         }
  124.     }
  125.     }    
  126.     
  127.     # Get Alpha's current name.
  128.     regexp {"([^"]+)" "ALFA" } [processes] "" ALPHA
  129.     set alpha::version [lindex [split [string trimleft [version] "Alpha Version"] ,] 0]
  130.     # set AlphaTcl version (the version of this library of .tcl files)
  131.     set alpha::tclversion 7.2
  132.     if {[info commands startupText] != ""} {
  133.     startupText "Alpha $alpha::version, AlphaTcl $alpha::tclversion, Tcl [info patchlevel]"
  134.     }
  135.     if {[regexp -nocase "for (ppc|68k)" [version]] || ![regexp "for" [version]]} {
  136.     set alpha::platform "alpha"
  137.     } 
  138.     
  139.     # PREFS points to a folder 'Alpha', we add the major version number
  140.     append PREFS "-v[lindex [split ${alpha::version} .] 0]"
  141.     if {![info exists alpha::modifier_keys]} {
  142.     set alpha::modifier_keys [list "Command" "cmd" "Option" "opt"]
  143.     }
  144.     # useful proc
  145.     if {[info tclversion] < 7.6} { 
  146.     set tcl_platform(platform) macintosh
  147.     # Alpha already has these two renamed internally
  148.     # they need their argument packaged as a list!
  149.     ;proc mkdir {dir} {
  150.         oldMkdir [list $dir]
  151.     }
  152.     ;proc rmdir {dir} {
  153.         oldRmdir [list $dir]
  154.     }
  155.     if {[info commands __file] == ""} {
  156.         rename file __file
  157.         ;proc file {cmd args} {
  158.         switch -- $cmd {
  159.             "join" {
  160.             regsub -all "::" [join $args ":"] ":" res
  161.             return $res
  162.             }
  163.             "copy" {eval copyFile $args}
  164.             "rename" {eval moveFile $args}
  165.             "delete" {
  166.             if {[file isdir [lindex $args 0]]} {
  167.                 eval rmdir $args
  168.             } else {
  169.                 eval removeFile $args
  170.             }
  171.             }
  172.             "mkdir" {eval mkdir $args}
  173.             "volumes" {
  174.             # Thanks to Jon
  175.             return [aebuild::result 'MACS' core getd ---- {obj {form:indx, want:type(cdis), seld:abso('all '), from:'null'()}} rtyp TEXT] 
  176.             }
  177.             default {uplevel 1 __file $cmd $args}
  178.         }
  179.         }
  180.     }
  181.     } 
  182.     # check if the user over-rides things
  183.     if {[file exists [file join ${HOME} AlphaPrefs]] \
  184.       && [file isdir [file join ${HOME} AlphaPrefs]]} {
  185.     set PREFS [file join ${HOME} AlphaPrefs]
  186.     } else {        
  187.     if {![file exists $PREFS]} { file mkdir $PREFS }
  188.     }
  189.     set alpha::noMenusYet 1
  190.     
  191.     # source v. important code
  192.     source [file join $HOME Tcl SystemCode library.tcl]
  193.     source [file join $HOME Tcl SystemCode coreFixes.tcl]
  194.  
  195.     alpha::makeAutoPath 0 $skipPrefs
  196.       
  197.     # get known packages
  198.     catch {cache::read index::feature}
  199.     # if configuration has changed, rebuild indices
  200.     if {[alpha::checkConfiguration]} {
  201.     alertnote "I need to rebuild the package indices.\
  202.       This'll take just a few seconds."
  203.     # power-user can use 'option' to avoid the rebuild
  204.     if {!([getModifiers] & 72)} {
  205.         alpha::makeIndices
  206.         rebuildTclIndices
  207.     }
  208.     }
  209.  
  210.     if {[alpha::package vcompare ${alpha::version} 7.2d1] < 0} {
  211.     alertnote "This version of Alpha is too old.\
  212.       Upgrade from\
  213.       http://alpha.olm.net/ or\
  214.       ftp://ftp.ucsd.edu/pub/alpha/ \
  215.       \r\rI'll quit now."
  216.     quit
  217.     }
  218.     # load the list of active packages from special cache
  219.     namespace eval global {}
  220.     if {!$skipPrefs} {
  221.     catch {cache::read configuration}
  222.     catch {unset mode::defaultfeatures}
  223.     }
  224.     if {![info exists global::features]} {
  225.     set global::features ""
  226.     }
  227.  
  228. # Now do all the more complex stuff:
  229. # (from now on, avoid use of 'source'.  Prefer to use auto-loading)
  230.  
  231.     # pull in smarterSource and internationalMenus packages
  232.     # if the user activated them
  233.     lappend alpha::earlyPackages smarterSource internationalMenus
  234.     alpha::package require Alpha
  235.     foreach pkg [set alpha::earlyPackages] {
  236.     if {[lsearch -exact ${global::features} $pkg] != -1} {
  237.         alpha::package require $pkg
  238.     }
  239.     }
  240.     unset pkg
  241.     
  242.     removeTemporaryFiles
  243.     alpha::getDefinitions
  244.     if {![llength ${global::features}]} {
  245.     lappend global::features internationalMenus filesetMenu
  246.     if {$tcl_platform(platform) == "macintosh"} {
  247.         lappend global::features internetConfigMenu eudoraMenu
  248.     }
  249.     if {!$skipPrefs} {
  250.         if {[dialog::yesno "Alpha contains a lot of useful additional functionality\
  251.           in the form of menus, packages and features.  Many of these provide\
  252.           basic things like completions, a recent files menu, keyboard macros,\
  253.           electric code insertion...\r\r  Would you like me to activate\
  254.           the standard feature set?  (Either\
  255.           way you can turn them on and off using the\
  256.           'Config->Preferences->Menus And Features' menu item)"]} {
  257.         lappend global::features recentFilesMenu elecCompletions \
  258.           elecExpansions macros elecBindings emacs autoContinueComment
  259.         }
  260.     }
  261.     }
  262.     if {!$skipPrefs} {
  263.     # Read both scalar and array definitions from preferences folder.
  264.     alpha::readUserDefs
  265.     if {[key::optionPressed]} {
  266.     }
  267.     }
  268.     # define v. important keyboard variables
  269.     keys::keyboardChanged
  270.     message "Building basic menus…"
  271.     menu::buildBasic
  272.     message "Binding keys…"
  273.     if {![info exists alpha::haveBasicKeys]} {
  274.     alpha::basicKeyBindings
  275.     }
  276.     alpha::keyBindings
  277.     alpha::useElectricTemplates
  278.     # Read in all packages, modes and menus.
  279.     message "Reading in packages…"
  280.     alpha::findAllPlugins
  281.     if {!$skipPrefs} {
  282.     # read preferences file
  283.     if {[catch {alpha::readUserPrefs} err]} {
  284.         append alpha::errorLog "\r" $err
  285.         unset err
  286.     }
  287.     }
  288.     # call anything that's attached to my keyboard.
  289.     hook::callAll keyboard $keyboard
  290.     message "Building complete menus…"
  291.     # build all menus completely.
  292.     alpha::buildMainMenus
  293.     # insert menus
  294.     global::insertAllMenus
  295.     # Bind special keys
  296.     bind::fromArray keys::specialBindings keys::specialProcs
  297.  
  298. # if we do anything else to a menu, it must now be rebuilt
  299. unset alpha::noMenusYet
  300.  
  301. # couple of random things
  302. alpha::makeColourList
  303.  
  304. # Add to chars considered part of words.
  305. addAlphaChars {_ÄÅÇÉÑÖÜáàâäãåçéèêëíìîïñóòôöõúùûüÅØæøæß}
  306. # Call all startup hooks
  307. hook::callAll startupHook *
  308. # Alerts and readme's for the user:
  309.  
  310.     if {!$skipPrefs} {
  311.     if {![info exists readReadme] \
  312.       || ([lindex $readReadme 0] != [alpha::package versions Alpha]) \
  313.       || ([lindex $readReadme 1] != [alpha::package versions AlphaTcl]) \
  314.     } {
  315.         addDef readReadme [list [alpha::package versions Alpha] [alpha::package versions AlphaTcl]]
  316.         edit -r [file join $HOME Help Readme]
  317.     } else {unset readReadme}
  318.     
  319.     if {[info exists alpha::readAtStartup]} {
  320.         foreach f ${alpha::readAtStartup} {
  321.         catch {edit -r $f}
  322.         }
  323.         unset alpha::readAtStartup
  324.         lappend modifiedVars alpha::readAtStartup
  325.     }
  326.     }
  327.  
  328. } err]} {
  329.     append alpha::errorLog "\r" $errorInfo
  330.     if {[dialog::yesno -y "View the error" -n "Continue" "That was a core startup error.  Alpha will probably not function correctly."]} {
  331.     dialog::alert $errorInfo
  332.     }
  333. }
  334. if {[info exists alpha::errorLog]} {
  335.     catch {
  336.     new -n "* Alpha startup error log *" -info ${alpha::errorLog}
  337.     unset alpha::errorLog
  338.     }
  339. }
  340. # call these two procs to sort out the menu enabled state.
  341. catch {
  342.     menuEnableHook [expr {[win::Current] != ""}]
  343.     requireOpenWindowsHook 2
  344. }
  345. message "Initialization Complete"
  346.  
  347.  
  348.  
  349.